home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / eulisp / feel0_89.lha / Feel / Src / ccc.c < prev    next >
C/C++ Source or Header  |  1993-03-24  |  10KB  |  404 lines
  1. /* ******************************************************************** */
  2. /* ccc.c             Copyright (C) Codemist and University of Bath 1989 */
  3. /*                                                                      */
  4. /* Comparing, copying and conversion.                                   */
  5. /* ******************************************************************** */
  6.  
  7. /*
  8.  * $Id: ccc.c,v 2.1 93/01/17 17:25:21 pab Exp $
  9.  *
  10.  * $Log:    ccc.c,v $
  11.  * Revision 2.1  93/01/17  17:25:21  pab
  12.  * 17 Jan 1993 The next generation...
  13.  * 
  14.  * Revision 1.10  1992/11/25  17:06:02  pab
  15.  * Removed some obsolete functions
  16.  *
  17.  * Revision 1.9  1992/05/19  11:15:24  pab
  18.  * fixed equal
  19.  *
  20.  * Revision 1.8  1992/02/27  15:49:10  pab
  21.  * lose type_condition
  22.  *
  23.  * Revision 1.7  1992/01/21  22:38:31  pab
  24.  * Fixed equal on structs
  25.  *
  26.  * Revision 1.6  1992/01/17  22:25:49  pab
  27.  * Added conversion+copy methods
  28.  *
  29.  * Revision 1.5  1992/01/09  22:28:44  pab
  30.  * Fixed for low tag ints
  31.  *
  32.  * Revision 1.4  1991/12/22  15:13:53  pab
  33.  * Xmas revision
  34.  *
  35.  * Revision 1.3  1991/11/15  13:44:25  pab
  36.  * copyalloc rev 0.01
  37.  *
  38.  * Revision 1.2  1991/09/11  12:07:03  pab
  39.  * 11/9/91 First Alpha release of modified system
  40.  *
  41.  * Revision 1.1  1991/08/12  16:49:29  pab
  42.  * Initial revision
  43.  *
  44.  * Revision 1.4  1991/02/14  10:07:28  kjp
  45.  * Added an eq lisp function handle for table optimisation.
  46.  *
  47.  * Revision 1.3  1991/02/14  05:59:24  kjp
  48.  * Fixed Fn_equal in the symbol case.
  49.  *
  50.  */
  51.  
  52. /*
  53.  * Change Log:
  54.  *   Version 1, March 1990 (Compiler rationalisation)
  55.  */
  56.  
  57. #include <stdio.h>
  58. #include <string.h>
  59. #include "funcalls.h"
  60. #include "defs.h"
  61. #include "structs.h"
  62.  
  63. #include "error.h"
  64. #include "global.h"
  65.  
  66. #include "calls.h"
  67. #include "modboot.h"
  68. #include "ngenerics.h"
  69.  
  70. LispObject function_eq;
  71.  
  72. EUFUN_2( Fn_eq, x, y)
  73. {
  74.   if (x == y) 
  75.     return(lisptrue);
  76.   else
  77.     return(nil);
  78. }
  79. EUFUN_CLOSE
  80.  
  81. /* Non-generic, hacked equal */
  82.  
  83. LispObject equal_lookup_table;
  84.  
  85. EUFUN_2( Fn_equal, x, y)
  86. {
  87.   while (TRUE) {
  88.     if (x == y) return lisptrue;
  89.     if (typeof(x) != typeof(y)) return nil;
  90.     switch (typeof(x)) {
  91.     case TYPE_CONS:
  92.       if (EUCALL_2(Fn_equal, CAR(x), CAR(y))) {
  93.     ARG_0(stackbase) = x = CDR(ARG_0(stackbase));
  94.     ARG_1(stackbase) = y = CDR(ARG_1(stackbase));
  95.     continue;
  96.       }
  97.       else return nil;
  98.     case TYPE_CHAR:
  99.       if ((((x->CHAR).code) == ((y->CHAR).code)) &&
  100.       (((x->CHAR).font) == ((y->CHAR).font))) return lisptrue;
  101.       else return nil;
  102.     case TYPE_STRING:
  103.       if (strcmp(stringof(x),stringof(y)) == 0) return lisptrue;
  104.       else return nil;
  105.     case TYPE_SYMBOL:
  106.       return nil;
  107.     case TYPE_THREAD:
  108.     case TYPE_STREAM:
  109.       CallError(stacktop,"Unimplemented facility in equal",nil,NONCONTINUABLE);
  110.     case TYPE_INT:
  111.       if (intval(x) == intval(y)) return lisptrue;
  112.       else return nil;
  113.     case TYPE_FLOAT:
  114.       if ((x->FLOAT).fvalue == (y->FLOAT).fvalue) return lisptrue;
  115.       else return nil;
  116.  
  117.     default:
  118.       {
  119. #ifdef veryverytacky /* Thu Sep 24 17:16:35 1992 */
  120. /**/
  121. /**/    LispObject foo = allocate_integer(stacktop,(int) typeof(x));
  122. /**/    LispObject ans;
  123. /**/    EUCALLSET_2(ans, Fn_table_ref, equal_lookup_table, foo);
  124. /**/    x = ARG_0(stackbase); y = ARG_1(stackbase);
  125. /**/    if (null(ans))
  126. #endif /* veryverytacky Thu Sep 24 17:16:35 1992 */
  127.   (void) CallError(stacktop,
  128.            "equal: No method for ~a", x, NONCONTINUABLE);
  129.     return nil; /* not reached */
  130.       }
  131.     }
  132.   }
  133.  
  134.   return(nil); /* dummy */
  135.  
  136. }
  137. EUFUN_CLOSE
  138.  
  139. /* Non-generic hacked copy */
  140.  
  141. EUFUN_1( Fn_copy, form)
  142. {
  143.   switch (typeof(form)) 
  144.     {
  145.     case TYPE_NULL:
  146.       return(nil);
  147.     case TYPE_INT:
  148.       return allocate_integer(stacktop,intval(form));
  149.     case TYPE_SYMBOL:
  150.       return form;
  151.  
  152.     case TYPE_CONS:
  153.       {
  154.     LispObject xx, yy;
  155.     EUCALLSET_1(xx, Fn_copy, CAR(form));
  156.     EUCALLSET_1(yy, Fn_copy, CDR(ARG_0(stackbase)));
  157.     return EUCALL_2(Fn_cons,xx, yy);
  158.       }
  159.     default:
  160.       (void) CallError(stacktop,
  161.                "copy: No method for ~a", form, NONCONTINUABLE);
  162.     }
  163.  
  164.   return(nil); /* dummy */
  165.  
  166. }
  167. EUFUN_CLOSE
  168.  
  169. /* ******************************************************************** */
  170. /*                          Generic Copying                             */
  171. /* ******************************************************************** */
  172.  
  173. EUFUN_1( Md_copy_Object, obj)
  174. {
  175.   return(Fn_copy(stackbase));
  176. }
  177. EUFUN_CLOSE
  178.  
  179. #ifndef NO_COMPACT
  180. #define myvref(v,i) vref(v,i)
  181. #else
  182. #define vrefupdate(v,i,obj) (*(&(v->VECTOR.base)+i)=obj)
  183. #define myvref(v,i) (*(&(v->VECTOR.base)+i))
  184. #endif
  185.  
  186. EUFUN_1( Md_copy_Vector, v)
  187. {
  188.   LispObject new;
  189.   int i;
  190.  
  191.   new = (LispObject) allocate_vector(stacktop,v->VECTOR.length);
  192.   v = ARG_0(stackbase);
  193.   for (i=0; i<v->VECTOR.length; ++i) {
  194.     vrefupdate(new,i,myvref(v,i));
  195.   }
  196.  
  197.   return(new);
  198. }
  199. EUFUN_CLOSE
  200.  
  201. EUFUN_1( Md_copy_Structure, str)
  202. {
  203.   LispObject new;
  204.  
  205.  
  206. #ifdef dunno /* Tue Jul 23 12:06:58 1991 */
  207. /**/  STACK(str);
  208. /**/  if (typeof(str) != TYPE_INSTANCE) return(Fn_copy(/*+:NULL:+*/str));
  209. /**/  new = allocate_instance(classof(str));
  210. /**/  STACK(new);
  211. /**/  new->INSTANCE.slots = Gf_copy(str->INSTANCE.slots);
  212. /**/  UNSTACK(2);
  213. #endif /* dunno Tue Jul 23 12:06:58 1991 */
  214.   
  215.   return(str);
  216. }
  217. EUFUN_CLOSE
  218.  
  219. /* ******************************************************************** */
  220. /*                          Generic Equality                            */
  221. /* ******************************************************************** */
  222. LispObject generic_equal;
  223.  
  224. EUFUN_2( Gf_equal, o1, o2)
  225. {
  226.   return(generic_apply_2(stacktop,generic_equal,o1,o2));
  227. }
  228. EUFUN_CLOSE
  229.  
  230. /* Basic methods... */
  231.  
  232. EUFUN_2( Md_equal_Object_Object, o1, o2)
  233. {
  234.   /* Same class? */
  235.  
  236.   if (classof(o1) != classof(o2)) return(nil);
  237.  
  238.   /* Same type? */
  239.  
  240.   if (typeof(o1) != typeof(o2)) return(nil);
  241.  
  242.   /* Instance? */
  243.  
  244. /**
  245.   if (typeof(o1) == TYPE_INSTANCE) {
  246.     if (Gf_equal(o1->INSTANCE.slots,o2->INSTANCE.slots) == nil) {
  247.       UNSTACK(2);
  248.       return(nil);
  249.     }
  250.     else {
  251.       UNSTACK(2);
  252.       return(lisptrue);
  253.     }
  254.   }
  255.   **/
  256.  
  257.   return(Fn_equal(stackbase));
  258. }
  259. EUFUN_CLOSE
  260.  
  261. EUFUN_2( Md_equal_Pair_Pair, p1, p2)
  262. {
  263.   LispObject xx;
  264.   if (p1 == p2) return(lisptrue);
  265.   if (p1 == nil) return(nil);
  266.   if (p2 == nil) return(nil);
  267.  
  268.   if (EUCALL_2(Gf_equal,CAR(p1),CAR(p2)) == nil)
  269.     return nil;
  270.   p1 = ARG_0(stackbase); p2 = ARG_1(stackbase);
  271.   if (EUCALL_2(Gf_equal,CDR(p1),CDR(p2)) == nil)
  272.     return(nil);
  273.   else
  274.     return(lisptrue);
  275. }
  276. EUFUN_CLOSE
  277.  
  278. EUFUN_2( Md_equal_Vector_Vector, v1, v2)
  279. {
  280.   int i;
  281.  
  282.   if (v1->VECTOR.length != v2->VECTOR.length) return(nil);
  283.  
  284.   for (i=0; i<v1->VECTOR.length; ++i) {
  285.     if (EUCALL_2(Gf_equal,myvref(v1,i),myvref(v2,i)) == nil) return(nil);
  286.     v1 = ARG_0(stackbase); v2 = ARG_1(stackbase);
  287.   }
  288.   
  289.   return(lisptrue);
  290. }
  291. EUFUN_CLOSE
  292.  
  293. EUFUN_2( Md_equal_Structure_Structure, s1, s2)
  294. {
  295.   int i;
  296.   LispObject res;
  297.  
  298.   if (classof(s1)==classof(s2)) 
  299.     return  nil;
  300.   
  301.   for (i=0; i<intval(classof(s1)->CLASS.local_count) ; i++)
  302.     {
  303.       if (slotref(s1,i)!=slotref(s2,i))
  304.     return nil;
  305.       i++;
  306.     }
  307.  
  308.   return lisptrue;
  309.   
  310. }
  311. EUFUN_CLOSE
  312.  
  313. EUFUN_2( Md_equal_Class_Class, c1, c2)
  314. {
  315.   return((c1 == c2 ? lisptrue : nil));
  316. }
  317. EUFUN_CLOSE
  318.  
  319.  
  320. /* ******************************************************************** */
  321. /*                          Generic Conversion                          */
  322. /* ******************************************************************** */
  323.  
  324. EUFUN_1( Md_generic_convert_Pair_Vector, l1)
  325. {
  326.   LispObject walker;
  327.   LispObject new;
  328.   int i;
  329.  
  330.   if (l1 == nil) return(nil);
  331.   new = (LispObject)
  332.           allocate_vector(stacktop,intval(EUCALL_1(Fn_length,l1)));
  333.  
  334.   l1 = ARG_0(stackbase);
  335.   for (i=0,walker = l1; is_cons(walker); ++i,walker = CDR(walker)) 
  336.     vrefupdate(new,i,CAR(walker));
  337.  
  338.   return(new);
  339. }
  340. EUFUN_CLOSE
  341.  
  342. EUFUN_1( Md_generic_convert_Vector_Pair, v1)
  343. {
  344.   extern LispObject Fn_convert_vector_list(LispObject*);
  345.   
  346.   return(Fn_convert_vector_list(stackbase));
  347. }
  348. EUFUN_CLOSE
  349.  
  350. #define CCC_ENTRIES 12
  351. MODULE Module_ccc;
  352. LispObject Module_ccc_values[CCC_ENTRIES];
  353.  
  354. void initialise_ccc(LispObject *stacktop)
  355. {
  356.   extern LispObject Basic_Structure;
  357.  
  358.   open_module(stacktop,
  359.           &Module_ccc,
  360.           Module_ccc_values,
  361.           "ccc",
  362.           CCC_ENTRIES);
  363.  
  364.   function_eq = make_module_function(stacktop,"eq",Fn_eq,2);
  365.   add_root(&function_eq);
  366.  
  367.   EUCALLSET_1(equal_lookup_table, make_table,NULL);
  368.   add_root(&equal_lookup_table);
  369.  
  370.   (void) make_module_function(stacktop,"generic_equal,Cons,Cons",
  371.                   Md_equal_Pair_Pair,2
  372.                   );
  373.   (void) make_module_function(stacktop,"generic_equal,Object,Object",
  374.                   Md_equal_Object_Object,2
  375.                   );
  376.   (void) make_module_function(stacktop,"generic_equal,Vector,Vector",
  377.                   Md_equal_Vector_Vector,2
  378.                   );
  379.   (void) make_module_function(stacktop,"generic_equal,Basic_Structure,Basic_Structure",
  380.                   Md_equal_Structure_Structure,2
  381.                   );
  382.   (void) make_module_function(stacktop,"generic_equal,Standard_Class,Standard_Class",
  383.                   Md_equal_Class_Class,2
  384.                   );
  385.  
  386.   generic_equal = make_wrapped_module_generic(stacktop,"equal",2,Gf_equal);
  387.   add_root(&generic_equal);
  388.   (void) make_module_function(stacktop,"generic_copy,Object",Md_copy_Object,1);
  389.   (void) make_module_function(stacktop,"generic_copy,Vector",Md_copy_Vector,1);
  390.   (void) make_module_function(stacktop,
  391.                   "generic_copy,Basic_Structure",Md_copy_Structure,1);
  392.  
  393.   /* conversion methods */
  394.   (void) make_module_function(stacktop,"generic_generic_convert,Cons,Vector",
  395.                   Md_generic_convert_Pair_Vector,1
  396.                   );
  397.   (void) make_module_function(stacktop,"generic_generic_convert,Vector,Cons",
  398.                   Md_generic_convert_Vector_Pair,1
  399.                   );
  400.  
  401.   close_module();
  402. }
  403.  
  404.